home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / access / FGLIB.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  56.5 KB  |  1,751 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C       Z F C A P U   -   Canonicalise a program-unit
  6. C
  7. C       This routine:
  8. C           a) sets the extended data for each statement-level node to
  9. C              the statement number (for comment indexing),
  10. C           b) converts arithmetic IFs to logical IFs (possibly + GOTO)
  11. C              whenever possible (i.e. if the three labels are not all
  12. C              different),
  13. C           c) adds COMMENT statements before control-flow statements
  14. C              which disappear under flowgraphing (i.e. CONTINUE,
  15. C              unconditional GOTO, ENDIF and ELSE),
  16. C           d) makes all DO loops end on unique CONTINUE statements.
  17. C
  18.  
  19.         SUBROUTINE ZFCAPU(PUROOT)
  20.         INTEGER PUROOT
  21.  
  22.         INTEGER MDNEST
  23.         PARAMETER (MDNEST=199)
  24.  
  25.         INTEGER STPTR,PTR,NODTYP,DOSP,DOLBL(MDNEST),NEWLBL(MDNEST),
  26.      +          LABEL,STMTNO,DPTR,PTR1,PTR2
  27.  
  28.         SAVE STMTNO
  29.  
  30.         INTEGER ZYGENL,ZYROOT,ZYCRND,ZYCMEX
  31.         EXTERNAL ZYGENL,ZYROOT,ERROR,ZYCHDN,ZYSATT,ZYADNX,ZYADSN,ZYCRND,
  32.      +           ZYSTXF,ZYCMEX
  33.  
  34. C---------------------------------------------------------
  35. C    TOOLPACK/1    Release: 2.5
  36. C---------------------------------------------------------
  37.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  38.         INTEGER NSYMS,NPUS,PUIDX(250),
  39.      +          SYMBOL(8,5003)
  40.         LOGICAL MODFLG
  41.  
  42.         SAVE /XCSYMS/
  43. C---------------------------------------------------------
  44. C    TOOLPACK/1    Release: 2.5
  45. C---------------------------------------------------------
  46. C
  47. C Common block and access functions for YP parse tree
  48. C
  49. C---------------------------------------------------------
  50. C    TOOLPACK/1    Release: 2.5
  51. C---------------------------------------------------------
  52.         COMMON/XCTREE/ROOT,TREE,TRETOP
  53.         INTEGER ROOT,TREE(4,46339),TRETOP
  54.  
  55.         SAVE /XCTREE/
  56. C Use "JABC12" to try to avoid conflicts with ordinary variables
  57.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  58.  
  59.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  60.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  61.         UP(JABC12)=(TREE(1,JABC12)/46340)
  62.         DOWN(JABC12)=TREE(2,JABC12)
  63.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  64.         NATTR(JABC12)=TREE(4,JABC12)
  65.  
  66.         IF (DOWN(ZYROOT()).EQ.PUROOT) STMTNO=1
  67.         STPTR=DOWN(PUROOT)
  68.         DOSP=0
  69.         LABEL=37000
  70.  
  71.  200    CALL ZYSTXF(STPTR,STMTNO)
  72.         NODTYP=NTYPE(STPTR)
  73.         IF (NODTYP.EQ.51 .OR. NODTYP.EQ.60 .OR.
  74.      +      NODTYP.EQ.59 .OR. NODTYP.EQ.62 .OR.
  75.      +      NODTYP.EQ.83) THEN
  76.             IF (ZYCMEX(STMTNO).EQ.-2) THEN
  77. C
  78. C Turn control-flow statements (which will disappear) which have
  79. C comments associated with them into Comment statements plus the
  80. C control-flow statement.
  81. C
  82.                 IF (NODTYP.EQ.51 .OR. NODTYP.EQ.60 .OR.
  83.      +              NODTYP.EQ.83 .AND. DOWN(STPTR).EQ.0) THEN
  84. C GOTO/ENDIF comments will follow the preceding statement
  85. C (RETURN without expression is treated as a GOTO)
  86.                     PTR=ZYCRND(131,0)
  87.                     CALL ZYSTXF(STPTR,0)
  88.                     CALL ZYSTXF(PTR,STMTNO)
  89.                     CALL ZYADNX(PTR,STPTR)
  90.                     CALL ZYADNX(STPTR,PTR)
  91.                 ELSE
  92. C (NODTYP.EQ.N_ELSE .OR. NODTYP.EQ.N_CONTINUE)
  93. C ELSE/CONTINUE comments will precede the following statement
  94.                     CALL ZYSTXF(STPTR,0)
  95.                     STMTNO=STMTNO-1
  96.                     CALL ZYADNX(ZYCRND(131,0),STPTR)
  97.                 END IF
  98.             END IF
  99.         END IF
  100. C
  101. C Canonicalise DO loop begins and ends
  102. C
  103.         IF (NODTYP.EQ.61) THEN
  104.             IF (DOSP.EQ.MDNEST) CALL ERROR('DO loops too deeply nested')
  105.             DOSP=DOSP+1
  106.             PTR=DOWN(STPTR)
  107.             IF (NTYPE(PTR).EQ.115) THEN
  108.                 PTR2=NEXT(PTR)
  109.                 CALL ZYREPL(PTR,PTR2)
  110.                 PTR1=ZYCRND(132,0)
  111.                 CALL ZYADNX(PTR1,STPTR)
  112.                 CALL ZYADNX(STPTR,PTR1)
  113.                 CALL ZYADSN(PTR1,PTR)
  114.                 SYMBOL(4,-DOWN(PTR))=PTR1
  115.                 PTR=PTR2
  116.             ELSE
  117.                 IF (NTYPE(PREV(STPTR)).EQ.62 .OR.
  118.      +              NTYPE(PREV(STPTR)).EQ.131) THEN
  119.                     PTR1=ZYCRND(132,0)
  120.                     CALL ZYADNX(PTR1,STPTR)
  121.                     CALL ZYADNX(STPTR,PTR1)
  122.                 ENDIF
  123.             ENDIF
  124.             DOLBL(DOSP)=-DOWN(PTR)
  125.             IF (SYMBOL(5,DOLBL(DOSP)).GT.0 .OR.
  126.      +          SYMBOL(6,DOLBL(DOSP)).GT.1) THEN
  127.                 NEWLBL(DOSP)=ZYGENL(LABEL,SYMBOL(3,DOLBL(DOSP)))
  128.                 CALL ZYCHDN(PTR,-NEWLBL(DOSP))
  129.                 IF (MOD(SYMBOL(6,DOLBL(DOSP)),
  130.      +                  1000).GT.1) THEN
  131.                     CALL ZYSATT(DOLBL(DOSP),6,
  132.      +                          SYMBOL(6,DOLBL(DOSP))-1)
  133.                 END IF
  134.             ELSE
  135.                 NEWLBL(DOSP)=0
  136.             END IF
  137.         ELSE IF (DOSP.GT.0) THEN
  138.             PTR=DOWN(STPTR)
  139.             IF (PTR.EQ.0) THEN
  140. C Do nothing
  141.             ELSE IF (NTYPE(PTR).EQ.115) THEN
  142.                 IF (DOLBL(DOSP).EQ.-DOWN(PTR)) THEN
  143.  300                IF (NEWLBL(DOSP).NE.0) THEN
  144.                         CALL ZYADNX(ZYCRND(62,
  145.      +                                     ZYCRND(115,
  146.      +                                            -NEWLBL(DOSP))),
  147.      +                              STPTR)
  148.                         STPTR=NEXT(STPTR)
  149.                         CALL ZYSATT(NEWLBL(DOSP),4,STPTR)
  150.                         CALL ZYSATT(NEWLBL(DOSP),6,1)
  151.                     ELSE IF (NODTYP.NE.62) THEN
  152.                         CALL ZYADNX(ZYCRND(62,0),STPTR)
  153.                         DPTR=DOWN(STPTR)
  154.                         CALL ZYADSN(NEXT(STPTR),DPTR)
  155.                         STPTR=NEXT(STPTR)
  156.                         CALL ZYSATT(DOLBL(DOSP),4,STPTR)
  157.                     END IF
  158.                     DOSP=DOSP-1
  159.                     IF (DOSP.GT.0) THEN
  160.                         IF (DOLBL(DOSP).EQ.DOLBL(DOSP+1)) GOTO 300
  161.                     END IF
  162.                 END IF
  163.             END IF
  164.         END IF
  165. C
  166. C Canonicalise arithmetic IFs, i.e. do away with them if possible
  167. C
  168.         IF (NODTYP.EQ.55) CALL XFFAIF(STPTR)
  169.         STPTR=NEXT(STPTR)
  170.         STMTNO=STMTNO+1
  171.         IF (STPTR.GT.0) GOTO 200
  172.         IF (DOSP.NE.0)
  173.      +      CALL ERROR('Internal Error: DO LOOP NESTING FAILURE')
  174.  
  175.         END
  176. C ----------------------------------------------------------------------
  177. C
  178. C       X F F A I F   -   (Internal) Fixup Arithmetic IF statements
  179. C
  180.  
  181.         SUBROUTINE XFFAIF(STPTR)
  182.         INTEGER STPTR
  183.  
  184.         INTEGER PTR,L1,L2,L3,LN,LGOTO,COND,LOTHER,ZERO(2)
  185.  
  186.         SAVE ZERO
  187.  
  188.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYCRND,ZYASTR
  189.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYCRND,ZYASTR,ZYADSN,ZYCHNT,
  190.      +           ZYDELT,ZYCHDN,ZYADNX
  191.  
  192.         DATA ZERO/48,129/
  193.  
  194.         PTR=ZYDOWN(STPTR)
  195.         IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  196.         PTR=ZYNEXT(PTR)
  197.         L1=-ZYDOWN(PTR)
  198.         PTR=ZYNEXT(PTR)
  199.         L2=-ZYDOWN(PTR)
  200.         PTR=ZYNEXT(PTR)
  201.         L3=-ZYDOWN(PTR)
  202.         LN=ZYDOWN(ZYNEXT(STPTR))
  203.         IF (LN.NE.0) THEN
  204.             IF (ZYNTYP(LN).EQ.115) THEN
  205.                 LN=-ZYDOWN(LN)
  206.             ELSE
  207.                 LN=0
  208.             END IF
  209.         END IF
  210.         LOTHER=0
  211.         IF (L1.EQ.L2) THEN
  212.             IF (L1.EQ.LN) THEN
  213.                 COND=93
  214.                 LGOTO=L3
  215.             ELSE
  216.                 COND=90
  217.                 LGOTO=L1
  218.                 IF (L3.NE.LN) LOTHER=L3
  219.             END IF
  220.         ELSE IF (L2.EQ.L3) THEN
  221.             IF (L2.EQ.LN) THEN
  222.                 COND=89
  223.                 LGOTO=L1
  224.             ELSE
  225.                 COND=94
  226.                 LGOTO=L2
  227.                 IF (L1.NE.LN) LOTHER=L1
  228.             END IF
  229.         ELSE IF (L1.EQ.L3) THEN
  230.             IF (L1.EQ.LN) THEN
  231.                 COND=91
  232.                 LGOTO=L2
  233.             ELSE
  234.                 COND=92
  235.                 LGOTO=L1
  236.                 IF (L2.NE.LN) LOTHER=L2
  237.             END IF
  238.         ELSE
  239.             RETURN
  240.         END IF
  241. C
  242. C  N_ARITHIF -> EXPR, L1, L2, L3 BECOMES
  243. C  N_LOG_IF  -> (COND -> EXPR, ICONST(0)), N_GOTO -> N_LABELREF(LGOTO)
  244. C
  245. C  I.E. L1 ==> COND,
  246. C       EXPR MOVED TO UNDER L1
  247. C       L2 ==> ICONST 0 AND MOVED TO UNDER L1 AFTER EXPR
  248. C       L3 ==> N_GOTO
  249. C       N_LABELREF CREATED UNDER L3
  250. C
  251.         CALL ZYCHNT(STPTR,56)
  252.         PTR=ZYDOWN(STPTR)
  253.         IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  254.         L1=ZYNEXT(PTR)
  255.         L2=ZYNEXT(L1)
  256.         L3=ZYNEXT(L2)
  257.         CALL ZYDELT(PTR)
  258.         CALL ZYCHNT(L1,COND)
  259.         CALL ZYADSN(L1,PTR)
  260.         CALL ZYCHNT(L2,107)
  261.         CALL ZYCHDN(L2,-ZYASTR(ZERO))
  262.         CALL ZYADNX(L2,PTR)
  263.         CALL ZYCHNT(L3,51)
  264.         CALL ZYADSN(L3,ZYCRND(116,-LGOTO))
  265.         IF (LOTHER.NE.0) THEN
  266.             CALL ZYADNX(ZYCRND(51,ZYCRND(116,-LOTHER)),STPTR)
  267.             STPTR=ZYNEXT(STPTR)
  268.         END IF
  269.  
  270.         END
  271. C ----------------------------------------------------------------------
  272. C
  273. C       Z F G R A F   -   Create flow graph of a program unit
  274. C
  275.  
  276.         LOGICAL FUNCTION ZFGRAF(PUROOT,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,
  277.      +                          NCASES,STARTN,IODWRN)
  278.         INTEGER MFGNOD,NCASES,PUROOT,FGSIZE,MAXCAS,STARTN,IODWRN
  279.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
  280.  
  281.         LOGICAL ZFFLOW,ZFSHED
  282.  
  283. C
  284. C Basic flow analysis
  285. C
  286.         ZFGRAF=ZFFLOW(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,PUROOT,
  287.      +                STARTN,IODWRN)
  288.         IF (ZFGRAF) THEN
  289. C
  290. C Construct virtual spanning tree and number the nodes accordingly
  291.             CALL ZFSPAN(FG,FGSIZE,STARTN,CASETB,MAXCAS)
  292. C
  293. C Nodes numbered properly, so we can now identify loop beginnings
  294. C and add repeat nodes.
  295. C
  296.             CALL ZFLOOP(FG,MFGNOD,STARTN,FGSIZE,CASETB,MAXCAS,NCASES,
  297.      +                  IODWRN)
  298. C
  299. C Repeat nodes inserted, can now calculate HEAD()
  300. C (false return is for irreducible flowgraphs - no further processing)
  301. C
  302.             ZFGRAF=ZFSHED(FG,FGSIZE,STARTN,CASETB,MAXCAS,IODWRN)
  303.             IF (ZFGRAF) THEN
  304. C
  305. C Add forward inarc counts
  306. C
  307.                 CALL ZFICNT(FG,FGSIZE,CASETB,MAXCAS)
  308. C
  309. C Calculate DOM()
  310. C
  311.                 CALL ZFSDOM(FG,FGSIZE,CASETB,MAXCAS,STARTN)
  312. C
  313. C Calculate FOLLOW sets: each node is in at most 1 follow set.
  314. C
  315.                 CALL ZFFOLL(FG,FGSIZE,CASETB,MAXCAS)
  316.             END IF
  317.         END IF
  318.  
  319.         END
  320. C ----------------------------------------------------------------------
  321. C
  322. C       Z F F L O W   -   Do basic flow analysis
  323. C
  324.  
  325.         LOGICAL FUNCTION ZFFLOW(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
  326.      +                          PUPTR,STARTN,IODWRN)
  327.         INTEGER MFGNOD,FGSIZE,MAXCAS,NCASES,PUPTR,STARTN,IODWRN
  328.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
  329.  
  330.         INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN,IO
  331.         PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6,
  332.      +             IO=7)
  333.  
  334.         INTEGER MDNEST,MAXJMP
  335.         PARAMETER (MDNEST=100,MAXJMP=500)
  336.  
  337.         INTEGER DOLVL,DOSTMT(MDNEST),ENDDO(MDNEST),NEXTST,NXT,FSTEXE,
  338.      +          JTABLE(2,MAXJMP),NESTLV,STPTR,FGNTYP,NJUMPS,PTR,
  339.      +          STTYPE(132)
  340.  
  341.         SAVE STTYPE
  342.  
  343.         LOGICAL XFLCAS
  344.  
  345.         INTEGER ZYJMPA
  346.         EXTERNAL ZYJMPA,ERROR
  347.  
  348. C---------------------------------------------------------
  349. C    TOOLPACK/1    Release: 2.5
  350. C---------------------------------------------------------
  351. C
  352. C Common block and access functions for YP parse tree
  353. C
  354. C---------------------------------------------------------
  355. C    TOOLPACK/1    Release: 2.5
  356. C---------------------------------------------------------
  357.         COMMON/XCTREE/ROOT,TREE,TRETOP
  358.         INTEGER ROOT,TREE(4,46339),TRETOP
  359.  
  360.         SAVE /XCTREE/
  361. C Use "JABC12" to try to avoid conflicts with ordinary variables
  362.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  363.  
  364.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  365.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  366.         UP(JABC12)=(TREE(1,JABC12)/46340)
  367.         DOWN(JABC12)=TREE(2,JABC12)
  368.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  369.         NATTR(JABC12)=TREE(4,JABC12)
  370.  
  371.         DATA STTYPE(6)/EXIT/
  372.         DATA STTYPE(7),STTYPE(8),STTYPE(16),
  373.      +       STTYPE(20),STTYPE(24),STTYPE(26),
  374.      +       STTYPE(30),STTYPE(35),STTYPE(37),
  375.      +       STTYPE(38),STTYPE(39),STTYPE(41),
  376.      +       STTYPE(78),STTYPE(121)
  377.      +       /14*NONEXE/
  378.         DATA STTYPE(18),STTYPE(49),STTYPE(131),
  379.      +       STTYPE(63),STTYPE(64),STTYPE(67),
  380.      +       STTYPE(82),STTYPE(50),STTYPE(132)
  381.      +       /9*SLC/
  382.         DATA STTYPE(65),STTYPE(66),STTYPE(72),
  383.      +       STTYPE(73),STTYPE(74),STTYPE(75),
  384.      +       STTYPE(76),STTYPE(77)
  385.      +       /8*IO/
  386.         DATA STTYPE(51),STTYPE(83)
  387.      +       /2*JUMP/
  388.         DATA STTYPE(52),STTYPE(53),STTYPE(55)
  389.      +       /3*CASE/
  390.         DATA STTYPE(56),STTYPE(57),STTYPE(58),
  391.      +       STTYPE(61)
  392.      +       /4*BRANCH/
  393.         DATA STTYPE(59),STTYPE(60),STTYPE(62)
  394.      +       /3*JOIN/
  395.  
  396.         DOLVL=0
  397.         NJUMPS=0
  398.         FGSIZE=0
  399.         STARTN=1
  400.         NCASES=0
  401.         STPTR=DOWN(PUPTR)
  402.         FSTEXE=0
  403.         ZFFLOW=.FALSE.
  404.  
  405.   50    IF (NTYPE(STPTR).EQ.18) THEN
  406.             IF (NCASES.EQ.0 .AND. FSTEXE.NE.0) THEN
  407.                 NCASES=1
  408.                 CASETB(1)=FSTEXE
  409.             END IF
  410.             NCASES=NCASES+1
  411.             CASETB(NCASES)=STPTR
  412.         ELSE IF (FSTEXE.EQ.0 .AND. STTYPE(NTYPE(STPTR)).NE.NONEXE) THEN
  413.             FSTEXE=STPTR
  414.         END IF
  415.         STPTR=NEXT(STPTR)
  416.         IF (STPTR.NE.0) GOTO 50
  417.         IF (NCASES.GT.0) CALL XFNODE(FG,MFGNOD,FGSIZE,-2,-NCASES,-1)
  418.         STPTR=DOWN(PUPTR)
  419.  
  420.  100    FGNTYP=STTYPE(NTYPE(STPTR))
  421.         IF (FGNTYP.EQ.EXIT) THEN
  422.             NEXTST=0
  423.             NXT=0
  424.         ELSE
  425. C
  426. C Find out which statement is supposed to be next in the normal
  427. C sequential execution scheme.
  428. C
  429.             NEXTST=STPTR
  430.  200        NEXTST=NEXT(NEXTST)
  431.             IF (STTYPE(NTYPE(NEXTST)).EQ.NONEXE) GOTO 200
  432.             NXT=NEXTST
  433. C
  434. C If the next executable statement is an ELSE or ELSEIF, control instead
  435. C passes to the next ENDIF at this nesting level of block-ifs.
  436. C (this is the only difference between ELSE and CONTINUE, ...)
  437. C
  438.             IF (NTYPE(NXT).EQ.59 .OR. NTYPE(NXT).EQ.58)
  439.      +      THEN
  440.                 NESTLV=0
  441.  300            NXT=NEXT(NXT)
  442.                 IF (NTYPE(NXT).EQ.57) THEN
  443.                     NESTLV=NESTLV+1
  444.                     GOTO 300
  445.                 ELSE IF (NTYPE(NXT).NE.60) THEN
  446.                     GOTO 300
  447.                 ELSE
  448.                     NESTLV=NESTLV-1
  449.                     IF (NESTLV.GE.0) GOTO 300
  450.                 END IF
  451. C
  452. C Also, control passes from the last statement of the DO body to the top
  453. C of the loop (where it is tested); the terminal statement (always a
  454. C continue) simply becomes a jump to the following code (loop exit).
  455.             ELSE IF (DOLVL.GT.0) THEN
  456.                 IF (NXT.EQ.ENDDO(DOLVL)) NXT=DOSTMT(DOLVL)
  457.             END IF
  458.         END IF
  459. C
  460. C Here we actually process the current statement
  461. C
  462.  400    IF (FGNTYP.EQ.IO) THEN
  463.             CALL XFIXIO(STPTR,FGNTYP)
  464.         ELSE IF (NTYPE(STPTR).EQ.82) THEN
  465. C Check out a subroutine call for alternate return addresses (CASE)
  466.             CALL XFCHCL(STPTR,FGNTYP)
  467.         END IF
  468. C Having straightened that out, we proceed...
  469.         IF (FGNTYP.EQ.SLC) THEN
  470. C Straight-Line-Code
  471.             IF (NTYPE(STPTR).EQ.63) THEN
  472.                 PTR=PREV(DOWN(UP(NXT)))
  473.                 CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,PTR,0)
  474.             ELSE
  475.                 CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,0)
  476.             END IF
  477.         ELSE IF (FGNTYP.EQ.BRANCH) THEN
  478. C LOG-IF, IF-THEN, ELSE-IF, DO
  479.             IF (NTYPE(STPTR).EQ.56) THEN
  480.                 PTR=DOWN(STPTR)
  481.                 IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  482.                 CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NEXT(PTR),NXT)
  483.                 STPTR=NEXT(PTR)
  484.                 FGNTYP=STTYPE(NTYPE(STPTR))
  485. C After doing logical IF, must do its dependent statement
  486.                 GOTO 400
  487.             ELSE IF (NTYPE(STPTR).NE.61) THEN
  488. C Some sort of IF block (IF-THEN or ELSE-IF).
  489. C The "true" outarc is simply the next statement (already set up for us
  490. C in NXT), so now we find the "false" outarc; this is the next ELSE-IF,
  491. C ELSE, or END-IF at this nesting level of IF blocks.
  492.                 NESTLV=0
  493.                 PTR=STPTR
  494.  500            PTR=NEXT(PTR)
  495.                 IF (NTYPE(PTR).EQ.57) THEN
  496.                     NESTLV=NESTLV+1
  497.                     GOTO 500
  498.                 ELSE IF (NESTLV.GT.0) THEN
  499.                     IF (NTYPE(PTR).EQ.60) NESTLV=NESTLV-1
  500.                     GOTO 500
  501.                 ELSE IF (NTYPE(PTR).NE.58 .AND.
  502.      +                   NTYPE(PTR).NE.59 .AND.
  503.      +                   NTYPE(PTR).NE.60) THEN
  504.                     GOTO 500
  505.                 END IF
  506.                 CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,PTR)
  507.             ELSE
  508. C We have a "DO" statement: the "true" outarc leads to the DO body
  509. C (already set up for us in NXT) so we must find the "false" outarc;
  510. C this is easy, since we have an ordinary label_ref for it.
  511.                 PTR=DOWN(STPTR)
  512.                 IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  513.                 IF (ZYJMPA(PTR).EQ.0) THEN
  514.                     CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
  515.                     RETURN
  516.                 END IF
  517.                 PTR=ZYJMPA(PTR)
  518.                 CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,PTR)
  519.                 IF (DOLVL.EQ.MDNEST)
  520.      +              CALL ERROR('DO loops too deeply nested')
  521.                 DOLVL=DOLVL+1
  522.                 DOSTMT(DOLVL)=STPTR
  523.                 ENDDO(DOLVL)=PTR
  524.             END IF
  525.         ELSE IF (FGNTYP.EQ.CASE) THEN
  526.             IF (.NOT.XFLCAS(STPTR,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
  527.      +                      NXT,JTABLE,MAXJMP,NJUMPS,IODWRN)) RETURN
  528.         ELSE IF (FGNTYP.EQ.EXIT) THEN
  529. C END only
  530.             CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,0,0)
  531.         ELSE IF (FGNTYP.EQ.JUMP) THEN
  532. C GOTO or RETURN
  533.             IF (NTYPE(STPTR).EQ.83) THEN
  534. C RETURN -- branches to END
  535.                 PTR=PREV(DOWN(UP(NXT)))
  536.                 IF (DOWN(STPTR).EQ.0) THEN
  537.                     CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,PTR)
  538.                 ELSE
  539. C Add another node if alternate RETURN though
  540.                     CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,PTR,0)
  541.                 END IF
  542.             ELSE
  543. C GOTO -- just branches
  544.                 PTR=DOWN(STPTR)
  545.                 IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  546.                 IF (ZYJMPA(PTR).EQ.0) THEN
  547.                     CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
  548.                     RETURN
  549.                 ELSE IF (ZYJMPA(PTR).EQ.STPTR) THEN
  550.                     CALL XFERRM('Infinite emp'//'ty loop',STPTR,IODWRN)
  551.                     RETURN
  552.                 END IF
  553.                 CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,ZYJMPA(PTR))
  554.             END IF
  555.         ELSE IF (FGNTYP.EQ.JOIN) THEN
  556. C CONTINUE or END IF or ELSE
  557.             IF (DOLVL.GT.0) THEN
  558.                 IF (ENDDO(DOLVL).EQ.STPTR) DOLVL=DOLVL-1
  559.                 IF (DOLVL.GT.0) THEN
  560.                     IF (ENDDO(DOLVL).EQ.NXT) NXT=DOSTMT(DOLVL)
  561.                 END IF
  562.             END IF
  563.             CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,NXT)
  564.         END IF
  565.  
  566.         STPTR=NEXTST
  567.         IF (STPTR.NE.0) GOTO 100
  568.  
  569.         IF (DOLVL.NE.0)
  570.      +      CALL ERROR('Internal Error: INCORRECT DO LOOP NESTING')
  571.         IF (NJUMPS.GT.0)
  572.      +      CALL XFIXJP(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,JTABLE,
  573.      +                  NJUMPS)
  574. C
  575. C Convert parse tree node numbers into flowgraph node numbers
  576. C
  577.         CALL XFCHNU(FG,FGSIZE,CASETB,MAXCAS,NCASES)
  578.         ZFFLOW=.TRUE.
  579.  
  580.         END
  581. C ----------------------------------------------------------------------
  582. C
  583. C       X F I X I O   -   (Internal) Work out whether an i/o stmt is slc
  584. C                         or case (i.e. if END=/ERR= used).
  585. C
  586.  
  587.         SUBROUTINE XFIXIO(STPTR,FGNTYP)
  588.         INTEGER STPTR,FGNTYP
  589.  
  590.         INTEGER SLC,CASE
  591.         PARAMETER (SLC=1,CASE=4)
  592.  
  593.         INTEGER PTR,PTR2,ENDKD(4),ERRKD(4)
  594.  
  595.         SAVE ENDKD,ERRKD
  596.  
  597.         INTEGER EQUAL
  598.         EXTERNAL EQUAL,ERROR
  599.  
  600. C---------------------------------------------------------
  601. C    TOOLPACK/1    Release: 2.5
  602. C---------------------------------------------------------
  603.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  604.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  605.  
  606.         SAVE /XCSTRI/
  607.  
  608. C---------------------------------------------------------
  609. C    TOOLPACK/1    Release: 2.5
  610. C---------------------------------------------------------
  611. C
  612. C Common block and access functions for YP parse tree
  613. C
  614. C---------------------------------------------------------
  615. C    TOOLPACK/1    Release: 2.5
  616. C---------------------------------------------------------
  617.         COMMON/XCTREE/ROOT,TREE,TRETOP
  618.         INTEGER ROOT,TREE(4,46339),TRETOP
  619.  
  620.         SAVE /XCTREE/
  621. C Use "JABC12" to try to avoid conflicts with ordinary variables
  622.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  623.  
  624.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  625.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  626.         UP(JABC12)=(TREE(1,JABC12)/46340)
  627.         DOWN(JABC12)=TREE(2,JABC12)
  628.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  629.         NATTR(JABC12)=TREE(4,JABC12)
  630.  
  631.         DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
  632.  
  633. C IO statements are either SLC (normal case) or CASE (if ERR/END= used)
  634.         PTR=DOWN(STPTR)
  635.  100    IF (NTYPE(PTR).NE.68) THEN
  636.             PTR=NEXT(PTR)
  637.             IF (PTR.NE.0) GOTO 100
  638.             FGNTYP=SLC
  639.         ELSE
  640.             PTR=DOWN(PTR)
  641.  200        IF (NTYPE(PTR).EQ.69) THEN
  642.                 PTR2=DOWN(PTR)
  643.                 IF (NTYPE(PTR2).NE.118) CALL ERROR(
  644.      +'IMPOSSIBLE ERROR: COULDN''T FIND I/O KEYWORD')
  645.                 IF (EQUAL(STRTXT(-DOWN(PTR2)),ENDKD).EQ.-2 .OR.
  646.      +              EQUAL(STRTXT(-DOWN(PTR2)),ERRKD).EQ.-2) THEN
  647.                     FGNTYP=CASE
  648.                 ELSE
  649.                     PTR=NEXT(PTR)
  650.                     IF (PTR.NE.0) GOTO 200
  651.                     FGNTYP=SLC
  652.                 END IF
  653.             ELSE
  654.                 PTR=NEXT(PTR)
  655.                 IF (PTR.NE.0) GOTO 200
  656.                 FGNTYP=SLC
  657.             END IF
  658.         END IF
  659.  
  660.         END
  661. C ----------------------------------------------------------------------
  662. C
  663. C       X F C H C L   -   (Internal) Check a CALL stmt for labels (CASE)
  664. C
  665.  
  666.         SUBROUTINE XFCHCL(STPTR,FGNTYP)
  667.         INTEGER STPTR,FGNTYP
  668.  
  669.         INTEGER CASE
  670.         PARAMETER (CASE=4)
  671.  
  672.         INTEGER PTR
  673.  
  674. C---------------------------------------------------------
  675. C    TOOLPACK/1    Release: 2.5
  676. C---------------------------------------------------------
  677. C
  678. C Common block and access functions for YP parse tree
  679. C
  680. C---------------------------------------------------------
  681. C    TOOLPACK/1    Release: 2.5
  682. C---------------------------------------------------------
  683.         COMMON/XCTREE/ROOT,TREE,TRETOP
  684.         INTEGER ROOT,TREE(4,46339),TRETOP
  685.  
  686.         SAVE /XCTREE/
  687. C Use "JABC12" to try to avoid conflicts with ordinary variables
  688.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  689.  
  690.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  691.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  692.         UP(JABC12)=(TREE(1,JABC12)/46340)
  693.         DOWN(JABC12)=TREE(2,JABC12)
  694.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  695.         NATTR(JABC12)=TREE(4,JABC12)
  696.  
  697.         PTR=DOWN(STPTR)
  698.  100    IF (NTYPE(PTR).EQ.116) THEN
  699.             FGNTYP=CASE
  700.         ELSE
  701.             PTR=NEXT(PTR)
  702.             IF (PTR.NE.0) GOTO 100
  703.         END IF
  704.  
  705.         END
  706. C ----------------------------------------------------------------------
  707. C
  708. C       X F L C A S   -   (Internal) Flowgraph a "case" statement
  709. C
  710.  
  711.         LOGICAL FUNCTION XFLCAS(STPTR,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,
  712.      +                        NCASES,NEXTST,JTABLE,MAXJMP,NJUMPS,IODWRN)
  713.         INTEGER STPTR,MFGNOD,FGSIZE,MAXCAS,NCASES,NEXTST,MAXJMP,NJUMPS,
  714.      +          IODWRN
  715.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,MAXJMP)
  716.  
  717.         INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN,IO,UNDEF
  718.         PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6,
  719.      +             IO=7,UNDEF=-1)
  720.  
  721.         INTEGER FGNTYP,CASES,PTR,I,TEXT(134),ENDKD(4),ERRKD(4)
  722.  
  723.         INTEGER ZYJMPA
  724.  
  725.         INTEGER EQUAL
  726.         EXTERNAL EQUAL,ZYGTST,ZYCHNT,ERROR
  727.  
  728. C---------------------------------------------------------
  729. C    TOOLPACK/1    Release: 2.5
  730. C---------------------------------------------------------
  731. C
  732. C Common block and access functions for YP parse tree
  733. C
  734. C---------------------------------------------------------
  735. C    TOOLPACK/1    Release: 2.5
  736. C---------------------------------------------------------
  737.         COMMON/XCTREE/ROOT,TREE,TRETOP
  738.         INTEGER ROOT,TREE(4,46339),TRETOP
  739.  
  740.         SAVE /XCTREE/
  741. C Use "JABC12" to try to avoid conflicts with ordinary variables
  742.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  743.  
  744.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  745.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  746.         UP(JABC12)=(TREE(1,JABC12)/46340)
  747.         DOWN(JABC12)=TREE(2,JABC12)
  748.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  749.         NATTR(JABC12)=TREE(4,JABC12)
  750.  
  751.         DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
  752.  
  753.         XFLCAS=.FALSE.
  754.  
  755. C AS-GOTO, CM-GOTO, ARITH-IF (with 3 different labels), or I/O
  756. C (with ERR= or END=).
  757.         FGNTYP=UNDEF
  758.         IF (NTYPE(STPTR).EQ.55) THEN
  759.             CASES=3
  760.         ELSE IF (NTYPE(STPTR).EQ.52 .OR.
  761.      +           NTYPE(STPTR).EQ.82) THEN
  762.             IF (NCASES.EQ.MAXCAS) CALL ERROR('Too many cases')
  763.             NCASES=NCASES+1
  764.             CASETB(NCASES)=NEXTST
  765.             CASES=0
  766.             PTR=DOWN(STPTR)
  767.             IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  768.             IF (NTYPE(PTR).EQ.54) PTR=DOWN(PTR)
  769.  100        IF (NTYPE(PTR).EQ.116) CASES=CASES+1
  770.             PTR=NEXT(PTR)
  771.             IF (PTR.NE.0) GOTO 100
  772.         ELSE IF (NTYPE(STPTR).EQ.53) THEN
  773.             CALL XFASGO(STPTR,FG,MFGNOD,CASETB,MAXCAS,NCASES,CASES,
  774.      +                  JTABLE,MAXJMP,NJUMPS,IODWRN)
  775.             IF (CASES.EQ.1) XFLCAS=.TRUE.
  776.             IF (CASES.LE.1) RETURN
  777.         ELSE
  778. C Must be IO statement
  779.             PTR=DOWN(STPTR)
  780.  200        IF (NTYPE(PTR).NE.68) THEN
  781.                 PTR=NEXT(PTR)
  782.                 GOTO 200
  783.             END IF
  784.             PTR=DOWN(PTR)
  785.             CASETB(NCASES+1)=NEXTST
  786.             CASES=1
  787.  300        IF (NTYPE(PTR).EQ.69) THEN
  788.                 CALL ZYGTST(-DOWN(DOWN(PTR)),TEXT)
  789.                 IF (EQUAL(TEXT,ENDKD).EQ.-2 .OR.
  790.      +              EQUAL(TEXT,ERRKD).EQ.-2) THEN
  791.                     CASES=CASES+1
  792.                     CASETB(NCASES+CASES)=ZYJMPA(NEXT(DOWN(PTR)))
  793.                     IF (CASETB(NCASES+CASES).EQ.0) THEN
  794.                         CALL XFULER(STPTR,-DOWN(NEXT(DOWN(PTR))),IODWRN)
  795.                         RETURN
  796.                     END IF
  797.                 END IF
  798.             END IF
  799.             PTR=NEXT(PTR)
  800.             IF (PTR.NE.0) GOTO 300
  801.             FGNTYP=IO
  802.         END IF
  803.         IF (NCASES+CASES.GT.MAXCAS) CALL ERROR('Too many cases')
  804.         IF (FGNTYP.NE.IO .AND. NTYPE(STPTR).NE.53) THEN
  805.             PTR=DOWN(STPTR)
  806.             IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  807.             IF (NTYPE(STPTR).EQ.55 .OR.
  808.      +          NTYPE(STPTR).EQ.82) THEN
  809.                 PTR=NEXT(PTR)
  810.             ELSE
  811.                 PTR=DOWN(PTR)
  812.             END IF
  813.             DO 400 I=1,CASES
  814.  350            IF (PTR.LE.0) CALL ERROR('Invalid multiple branch')
  815.                 IF (NTYPE(PTR).EQ.116) THEN
  816.                     CASETB(NCASES+I)=ZYJMPA(PTR)
  817.                     IF (CASETB(NCASES+I).EQ.0) THEN
  818.                         CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
  819.                         RETURN
  820.                     END IF
  821.                 ELSE
  822.                     PTR=NEXT(PTR)
  823.                     GOTO 350
  824.                 END IF
  825.                 PTR=NEXT(PTR)
  826.  400        CONTINUE
  827.         END IF
  828.         IF (FGNTYP.EQ.IO) THEN
  829.             CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES,-NCASES-1)
  830.         ELSE IF (NTYPE(STPTR).EQ.52 .OR.
  831.      +           NTYPE(STPTR).EQ.82) THEN
  832.             CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES-1,-NCASES)
  833.         ELSE
  834.             CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES,-NCASES-1)
  835.             IF (NTYPE(STPTR).EQ.53) CALL ZYCHNT(STPTR,52)
  836.         END IF
  837.         NCASES=NCASES+CASES
  838.         XFLCAS=.TRUE.
  839.  
  840.         END
  841. C ----------------------------------------------------------------------
  842. C
  843. C       X F A S G O   -   Flowgraph an assigned GOTO by converting it to
  844. C                         a computed GOTO
  845. C
  846.  
  847.         SUBROUTINE XFASGO(STPTR,FG,MFGNOD,CASETB,MAXCAS,NCASES,CASES,
  848.      +                    JTABLE,MAXJMP,NJUMPS,IODWRN)
  849.         INTEGER STPTR,MFGNOD,MAXCAS,NCASES,CASES,MAXJMP,NJUMPS,IODWRN
  850.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,MAXJMP)
  851.  
  852.         INTEGER PTR,SYMPTR,I,PTR2,SYMBOL(8),TEXT(134),PTR3
  853.  
  854.         INTEGER ZYASTR,ITOC,ZYCRND
  855.         EXTERNAL ZYASTR,ITOC,ZYCRND,ZYCHNT,ZYADNX,PUTCH,ERROR,ZYGTSY,
  856.      +           ZMESS,ZYCHDN,ZYDELT
  857.  
  858. C---------------------------------------------------------
  859. C    TOOLPACK/1    Release: 2.5
  860. C---------------------------------------------------------
  861. C
  862. C Common block and access functions for YP parse tree
  863. C
  864. C---------------------------------------------------------
  865. C    TOOLPACK/1    Release: 2.5
  866. C---------------------------------------------------------
  867.         COMMON/XCTREE/ROOT,TREE,TRETOP
  868.         INTEGER ROOT,TREE(4,46339),TRETOP
  869.  
  870.         SAVE /XCTREE/
  871. C Use "JABC12" to try to avoid conflicts with ordinary variables
  872.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  873.  
  874.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  875.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  876.         UP(JABC12)=(TREE(1,JABC12)/46340)
  877.         DOWN(JABC12)=TREE(2,JABC12)
  878.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  879.         NATTR(JABC12)=TREE(4,JABC12)
  880.  
  881.         PTR=DOWN(STPTR)
  882.         IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  883.         IF (NTYPE(PTR).NE.108)
  884.      +      CALL ERROR('IMPOSSIBLE ERROR: INVALID ASSIGNED GOTO')
  885.         SYMPTR=-DOWN(PTR)
  886.         PTR=UP(STPTR)
  887.         IF (NTYPE(PTR).EQ.56) PTR=UP(PTR)
  888.         PTR=DOWN(PTR)
  889.         CASES=0
  890.  
  891.  100    IF (NTYPE(PTR).EQ.56) THEN
  892.             PTR2=NEXT(DOWN(PTR))
  893.         ELSE
  894.             PTR2=PTR
  895.         END IF
  896.         IF (NTYPE(PTR2).EQ.50) THEN
  897.             PTR3=DOWN(PTR2)
  898.             IF (NTYPE(PTR3).EQ.115) PTR3=NEXT(PTR3)
  899.             CALL ZYGTSY(-DOWN(PTR3),SYMBOL)
  900.             IF (SYMBOL(4).EQ.0) THEN
  901.                 CALL XFULER(PTR,-DOWN(PTR3),IODWRN)
  902.                 CASES=0
  903.                 RETURN
  904.             END IF
  905. C Make sure it is not a FORMAT reference!
  906.             IF (NTYPE(SYMBOL(4)).NE.78 .AND.
  907.      +          -DOWN(NEXT(PTR3)).EQ.SYMPTR) THEN
  908.                 DO 200 I=1,CASES
  909.                     IF (CASETB(NCASES+I).EQ.-DOWN(PTR3))
  910.      +                  GOTO 300
  911.  200            CONTINUE
  912. C New entry for table...
  913.                 IF (NCASES+CASES.EQ.MAXCAS)
  914.      +              CALL ERROR('Too many cases (ASSIGN)')
  915.                 CASES=CASES+1
  916.                 CASETB(NCASES+I)=-DOWN(PTR3)
  917. C Convert ASSIGN statement into assignment statement
  918.  300            CALL ZYCHNT(PTR2,49)
  919.                 CALL ZYCHNT(PTR3,107)
  920.                 CALL ZYADNX(PTR3,NEXT(PTR3))
  921.                 IF (ITOC(I-1,TEXT,4).GT.2 .AND. IODWRN.GE.0)
  922.      +             CALL ZMESS('MORE THAN 100 ASSIGN STATEMENTS!',IODWRN)
  923.                 CALL ZYCHDN(PTR3,-ZYASTR(TEXT))
  924.             END IF
  925.         END IF
  926.         PTR=NEXT(PTR)
  927.         IF (PTR.NE.0) GOTO 100
  928.         IF (CASES.EQ.0) THEN
  929.             CALL XFERRM('No ASSIGNs for assigned GOTO',STPTR,IODWRN)
  930.         ELSE
  931. C The first alternative becomes the "fall-through" case.
  932.             CALL ZYGTSY(CASETB(NCASES+1),SYMBOL)
  933.             IF (CASES.EQ.1) THEN
  934. C If only one alternative, turn into a GOTO...
  935.                 CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,
  936.      +                      SYMBOL(4))
  937. C Convert now in case program gets output as is (i.e. unstructurable)
  938.                 CALL ZYCHNT(STPTR,51)
  939.                 PTR2=DOWN(STPTR)
  940.                 IF (NTYPE(PTR2).EQ.115) PTR2=NEXT(PTR2)
  941.                 CALL ZYCHNT(PTR2,116)
  942.                 CALL ZYCHDN(PTR2,-CASETB(NCASES+1))
  943.                 IF (NEXT(PTR2).NE.0) CALL ZYDELT(NEXT(PTR2))
  944.                 PTR2=STPTR
  945.                 IF (NTYPE(UP(PTR2)).EQ.56) PTR2=UP(PTR2)
  946.                 IF (IODWRN.GE.0)
  947.      +              CALL XFERRM('Only one target for assigned goto',
  948.      +                          PTR2,IODWRN)
  949.             ELSE
  950.                 CASETB(NCASES+1)=SYMBOL(4)
  951. C FLCASE will change the N_ASGOTO to N_CMGOTO later on
  952. C If no label list create one with a (bogus) single element
  953.                 PTR=DOWN(STPTR)
  954.                 IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  955.                 IF (NEXT(PTR).EQ.0)
  956.      +              CALL ZYADNX(ZYCRND(54,
  957.      +                                 ZYCRND(116,0)),
  958.      +                          PTR)
  959. C Put the label list before the variable for a computed goto
  960.                 CALL ZYADNX(PTR,NEXT(PTR))
  961. C Position to the first label in the list
  962.                 PTR=DOWN(STPTR)
  963.                 IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  964.                 PTR=DOWN(PTR)
  965.                 DO 400 I=2,CASES
  966.                     CALL ZYCHDN(PTR,-CASETB(NCASES+I))
  967.                     IF (NEXT(PTR).EQ.0 .AND. I.LT.CASES)
  968.      +                  CALL ZYADNX(ZYCRND(116,0),PTR)
  969.                     CALL ZYGTSY(CASETB(NCASES+I),SYMBOL)
  970.                     CASETB(NCASES+I)=SYMBOL(4)
  971.                     PTR=NEXT(PTR)
  972.  400            CONTINUE
  973.                 IF (PTR.NE.0) THEN
  974. C Delete extraneous parts of label list
  975.  500                IF (NEXT(PTR).NE.0) THEN
  976.                         CALL ZYDELT(NEXT(PTR))
  977.                         GOTO 500
  978.                     END IF
  979.                     CALL ZYDELT(PTR)
  980.                 END IF
  981.             END IF
  982.         END IF
  983.  
  984.         END
  985. C ----------------------------------------------------------------------
  986. C
  987. C       X F I X J P   -   Fix jump addresses (use jump table to modify
  988. C                         flowgraph pointers)
  989. C
  990.  
  991.         SUBROUTINE XFIXJP(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,JTABLE,
  992.      +                    NJUMPS)
  993.         INTEGER MFGNOD,FGSIZE,MAXCAS,NCASES,NJUMPS
  994.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,NJUMPS)
  995.  
  996.         INTEGER I,J
  997.  
  998.         EXTERNAL ERROR
  999.  
  1000. C
  1001. C Finished first pass through the tree, now use the jump table to fixup
  1002. C control flow by GOTO/CONTINUE/ENDIF/etc
  1003. C
  1004.         DO 200 I=1,FGSIZE
  1005.             DO 100 J=1,NJUMPS
  1006.                 IF (JTABLE(1,J).EQ.FG(1,I))
  1007.      +              CALL ERROR('INTERNAL ERROR: BAD JUMP TABLE')
  1008.                 IF (JTABLE(1,J).EQ.FG(2,I))
  1009.      +              FG(2,I)=JTABLE(2,J)
  1010.                 IF (JTABLE(1,J).EQ.FG(3,I))
  1011.      +              FG(3,I)=JTABLE(2,J)
  1012.  100        CONTINUE
  1013.  200    CONTINUE
  1014.         DO 400 I=1,NCASES
  1015.             DO 300 J=1,NJUMPS
  1016.                 IF (CASETB(I).EQ.JTABLE(1,J)) CASETB(I)=JTABLE(2,J)
  1017.  300        CONTINUE
  1018.  400    CONTINUE
  1019.  
  1020.         END
  1021. C ----------------------------------------------------------------------
  1022. C
  1023. C       X F C H N U   -   (Internal) Change parse tree node numbers to
  1024. C                                    flowgraph node numbers
  1025. C
  1026. C (this is an N**2 algorithm: this can be improved upon)
  1027. C
  1028.  
  1029.         SUBROUTINE XFCHNU(FG,FGSIZE,CASETB,MAXCAS,NCASES)
  1030.         INTEGER FGSIZE,MAXCAS,NCASES
  1031.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1032.  
  1033.         INTEGER I,J
  1034.  
  1035.         DO 300 I=1,FGSIZE
  1036.             DO 100 J=1,FGSIZE
  1037.                 IF (FG(2,J).EQ.FG(1,I).AND.
  1038.      +              FG(1,I).NE.-2)
  1039.      +              FG(2,J)=I
  1040.                 IF (FG(3,J).EQ.FG(1,I))
  1041.      +              FG(3,J)=I
  1042.  100        CONTINUE
  1043.             DO 200 J=1,NCASES
  1044.                 IF (CASETB(J).EQ.FG(1,I))
  1045.      +              CASETB(J)=I
  1046.  200        CONTINUE
  1047.  300    CONTINUE
  1048.  
  1049.         END
  1050. C ----------------------------------------------------------------------
  1051. C
  1052. C       X F A D D J   -   (Internal) Add a jump to the jump table
  1053. C
  1054.  
  1055.         SUBROUTINE XFADDJ(JTABLE,MAXJMP,NJUMPS,JFROM,JTO)
  1056.         INTEGER MAXJMP,NJUMPS,JFROM,JTO,JTABLE(2,MAXJMP)
  1057.  
  1058.         INTEGER I
  1059.  
  1060.         EXTERNAL ERROR
  1061.  
  1062.         IF (NJUMPS.EQ.MAXJMP) CALL ERROR(
  1063.      +      'XFADDJ: TOO MANY CONTROL TRANSFERS - JUMP TABLE OVERFLOW')
  1064.         NJUMPS=NJUMPS+1
  1065.         JTABLE(1,NJUMPS)=JFROM
  1066.         JTABLE(2,NJUMPS)=JTO
  1067.         DO 100 I=1,NJUMPS-1
  1068.             IF (JTABLE(1,I).EQ.JTO) JTABLE(2,NJUMPS)=JTABLE(2,I)
  1069.  100    CONTINUE
  1070.         DO 200 I=1,NJUMPS-1
  1071.             IF (JTABLE(2,I).EQ.JFROM) JTABLE(2,I)=JTABLE(2,NJUMPS)
  1072.  200    CONTINUE
  1073.  
  1074.         END
  1075. C ----------------------------------------------------------------------
  1076. C
  1077. C       Z F S P A N   -   Construct flowgraph's (virtual) spanning tree
  1078. C                         and number nodes using a depth-first search.
  1079. C
  1080.  
  1081.         SUBROUTINE ZFSPAN(FG,FGSIZE,STARTN,CASETB,MAXCAS)
  1082.         INTEGER FGSIZE,STARTN,MAXCAS
  1083.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1084.  
  1085.         INTEGER I,PTR,NXT,NUMBER,FROM
  1086.  
  1087.         EXTERNAL ERROR
  1088.  
  1089.         DO 100 I=1,FGSIZE
  1090.             FG(4,I)=0
  1091.  100    CONTINUE
  1092.         NUMBER=FGSIZE
  1093.         PTR=STARTN
  1094.         FROM=0
  1095.  200    FG(4,PTR)=-1
  1096. C First stack the node we just came from (0 at top)
  1097.         FG(8,PTR)=FROM
  1098.         FROM=PTR
  1099. C Traverse a "true" arc if possible
  1100.         IF (FG(2,PTR).GT.0) THEN
  1101.             IF (FG(4,FG(2,PTR)).EQ.0) THEN
  1102.                 PTR=FG(2,PTR)
  1103.                 GOTO 200
  1104.             END IF
  1105.         END IF
  1106. C Traverse a "false" arc if possible
  1107.         IF (FG(3,PTR).GT.0) THEN
  1108.             IF (FG(4,FG(3,PTR)).EQ.0) THEN
  1109.                 PTR=FG(3,PTR)
  1110.                 GOTO 200
  1111.             END IF
  1112.         END IF
  1113. C Traverse an element in a multiple branch if possible
  1114.         IF (FG(2,PTR).LT.0) THEN
  1115.             NXT=-FG(2,PTR)
  1116.             I=-FG(3,PTR)
  1117.  300        IF (FG(4,CASETB(I)).EQ.0) THEN
  1118.                 PTR=CASETB(I)
  1119.                 GOTO 200
  1120.             END IF
  1121.             I=I+1
  1122.             NXT=NXT-1
  1123.             IF (NXT.GT.0) GOTO 300
  1124.         END IF
  1125. C All descendents visited: number this node properly and return
  1126. C to its parent.
  1127.         FG(4,PTR)=NUMBER
  1128.         NUMBER=NUMBER-1
  1129.         FROM=FG(8,PTR)
  1130.         IF (FROM.NE.0) THEN
  1131.             FG(8,PTR)=0
  1132.             PTR=FROM
  1133.             FROM=FG(8,PTR)
  1134.             GOTO 200
  1135.         END IF
  1136.  
  1137.         END
  1138. C ----------------------------------------------------------------------
  1139. C
  1140. C       Z F L O O P   -   Add repeat nodes to the flowgraph
  1141. C
  1142.  
  1143.         SUBROUTINE ZFLOOP(FG,MFGNOD,STARTN,FGSIZE,CASETB,MAXCAS,NCASES,
  1144.      +                    IODWRN)
  1145.         INTEGER MFGNOD,STARTN,FGSIZE,MAXCAS,NCASES,IODWRN
  1146.         INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
  1147.  
  1148.         INTEGER I,J,N
  1149.  
  1150.         DO 100 I=1,FGSIZE
  1151.             FG(5,I)=0
  1152.  100    CONTINUE
  1153.         DO 300 I=1,FGSIZE
  1154.             IF (FG(2,I).GE.0) THEN
  1155. C Check "true" outarc first
  1156.                 CALL XFCFBA(FG,MFGNOD,FGSIZE,FG(2,I),
  1157.      +                    FG(4,I),IODWRN)
  1158. C Check "false" outarc next
  1159.                 CALL XFCFBA(FG,MFGNOD,FGSIZE,FG(3,I),
  1160.      +                    FG(4,I),IODWRN)
  1161.             ELSE
  1162. C Check multiple branch outarcs
  1163.                 J=-FG(3,I)
  1164.                 N=-FG(2,I)
  1165.  200            CALL XFCFBA(FG,MFGNOD,FGSIZE,CASETB(J),FG(4,I),
  1166.      +                      IODWRN)
  1167.                 J=J+1
  1168.                 N=N-1
  1169.                 IF (N.GT.0) GOTO 200
  1170.             END IF
  1171.  300    CONTINUE
  1172. C If repeat node inserted before start node, make it the start node.
  1173.         IF (FG(5,STARTN).NE.0) STARTN=FG(5,STARTN)
  1174. C Make forward arcs to the previously repeating nodes point to the
  1175. C new repeat nodes
  1176.         DO 400 I=1,FGSIZE
  1177.             IF (FG(1,I).NE.(-1)) THEN
  1178.                 IF (FG(2,I).GT.0) THEN
  1179.                     IF (FG(5,FG(2,I)).NE.0)
  1180.      +                  FG(2,I)=FG(5,FG(2,I))
  1181.                 END IF
  1182.                 IF (FG(3,I).GT.0) THEN
  1183.                     IF (FG(5,FG(3,I)).NE.0)
  1184.      +                  FG(3,I)=FG(5,FG(3,I))
  1185.                 END IF
  1186.             END IF
  1187.  400    CONTINUE
  1188.         DO 500 I=1,NCASES
  1189.             IF (FG(5,CASETB(I)).NE.0)
  1190.      +          CASETB(I)=FG(5,CASETB(I))
  1191.  500    CONTINUE
  1192.  
  1193.         END
  1194. C ----------------------------------------------------------------------
  1195. C
  1196. C       X F C F B A   -   (Internal) Check For Back Arc
  1197. C                                    (and add repeat node if found)
  1198. C
  1199.  
  1200.         SUBROUTINE XFCFBA(FG,MFGNOD,FGSIZE,NODE,NUMBER,IODWRN)
  1201.         INTEGER MFGNOD,FGSIZE,NODE,NUMBER,IODWRN
  1202.         INTEGER FG(8,MFGNOD)
  1203.  
  1204. C---------------------------------------------------------
  1205. C    TOOLPACK/1    Release: 2.5
  1206. C---------------------------------------------------------
  1207. C
  1208. C Common block and access functions for YP parse tree
  1209. C
  1210. C---------------------------------------------------------
  1211. C    TOOLPACK/1    Release: 2.5
  1212. C---------------------------------------------------------
  1213.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1214.         INTEGER ROOT,TREE(4,46339),TRETOP
  1215.  
  1216.         SAVE /XCTREE/
  1217. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1218.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1219.  
  1220.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1221.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1222.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1223.         DOWN(JABC12)=TREE(2,JABC12)
  1224.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1225.         NATTR(JABC12)=TREE(4,JABC12)
  1226.  
  1227.         IF (NODE.GT.0 .AND. NUMBER.GT.0) THEN
  1228.             IF (FG(4,NODE).LE.NUMBER) THEN
  1229.                 IF (FG(5,NODE).NE.0) THEN
  1230.                     NODE=FG(5,NODE)
  1231.                 ELSE
  1232.                     CALL XFNODE(FG,MFGNOD,FGSIZE,-1,NODE,0)
  1233.                     FG(4,FGSIZE)=FG(4,NODE)
  1234.                     FG(5,NODE)=FGSIZE
  1235.                     IF (FG(4,FGSIZE).EQ.NUMBER)
  1236.      +                  CALL XFERRM('Null loop detected',
  1237.      +                              FG(1,NODE),IODWRN)
  1238.                     NODE=FGSIZE
  1239.                 END IF
  1240.             END IF
  1241.         END IF
  1242.  
  1243.         END
  1244. C ----------------------------------------------------------------------
  1245. C
  1246. C       X F N O D E   -   (Internal) Add a flowgraph node
  1247. C
  1248.  
  1249.         SUBROUTINE XFNODE(FG,MFGNOD,FGSIZE,PTNODE,TRUE,FALSE)
  1250.         INTEGER MFGNOD,FGSIZE,PTNODE,TRUE,FALSE
  1251.         INTEGER FG(8,MFGNOD)
  1252.  
  1253.         EXTERNAL ERROR
  1254.  
  1255.         IF (FGSIZE.EQ.MFGNOD) CALL ERROR('Program unit too complicated')
  1256.         FGSIZE=FGSIZE+1
  1257.         FG(1,FGSIZE)=PTNODE
  1258.         FG(2,FGSIZE)=TRUE
  1259.         FG(3,FGSIZE)=FALSE
  1260.         FG(4,FGSIZE)=0
  1261.         FG(5,FGSIZE)=0
  1262.         FG(6,FGSIZE)=0
  1263.         FG(7,FGSIZE)=0
  1264.         FG(8,FGSIZE)=0
  1265.  
  1266.         END
  1267. C ----------------------------------------------------------------------
  1268. C
  1269. C       Z F S H E D   -   Traverse a basic flowgraph, annotating it with
  1270. C                         HEAD pointers.
  1271. C
  1272.  
  1273.         LOGICAL FUNCTION ZFSHED(FG,FGSIZE,STARTN,CASETB,MAXCAS,IODWRN)
  1274.         INTEGER FGSIZE,STARTN,MAXCAS,IODWRN
  1275.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1276.  
  1277.         INTEGER PTRSTK,BRNSTK,VISITD
  1278.         PARAMETER (PTRSTK=6,BRNSTK=7,VISITD=8)
  1279.  
  1280.         INTEGER I,BRNUM,PTR,NXT,J,FROM,FROMB
  1281.  
  1282.         LOGICAL XSHEAD
  1283.  
  1284.         EXTERNAL ERROR
  1285.  
  1286.         ZFSHED=.FALSE.
  1287.  
  1288. C
  1289. C ... Set FG(fg_head,*) to HEAD()
  1290. C ... FG(fg_dom,*) & FG(fg_inarcs,*) used as a stack
  1291. C ... FG(fg_follow,*) used as "visited" pointer
  1292. C
  1293.         DO 100 I=1,FGSIZE
  1294.             FG(5,I)=0
  1295. C FG(fg_dom,I) already set to zero on entry
  1296. C FG(fg_inarcs,I) already set to zero on entry
  1297. C FG(fg_follow,I) already set to zero on entry
  1298.  100    CONTINUE
  1299.  
  1300.         BRNUM=0
  1301.         PTR=STARTN
  1302.         FROM=0
  1303.         FROMB=0
  1304.  200    CONTINUE
  1305.         FG(PTRSTK,PTR)=FROM
  1306.         FG(BRNSTK,PTR)=FROMB
  1307. C Mark this node as visited
  1308.         FG(VISITD,PTR)=1
  1309.         FROM=PTR
  1310.         FROMB=BRNUM
  1311. C Traverse a forward "true" arc if we have not yet already done so
  1312.         IF (FG(2,PTR).GT.0 .AND. BRNUM.EQ.0) THEN
  1313.             IF (FG(4,FG(2,PTR)).LT.FG(4,PTR) .OR.
  1314.      +          FG(4,FG(2,PTR)).EQ.FG(4,PTR) .AND.
  1315.      +          FG(1,FG(2,PTR)).EQ.-1) THEN
  1316. C arc is a backward (loop) arc -- set head refs
  1317.                 IF (.NOT.XSHEAD(FG,FGSIZE,PTR,FG(2,PTR),IODWRN))
  1318.      +                  RETURN
  1319.             ELSE IF (FG(VISITD,FG(2,PTR)).EQ.0) THEN
  1320.                 PTR=FG(2,PTR)
  1321.                 GOTO 200
  1322.             ELSE
  1323.                 IF (FG(5,FG(2,PTR)).NE.0) THEN
  1324.                     IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
  1325.      +                              FG(5,FG(2,PTR)),IODWRN))
  1326.      +                  RETURN
  1327.                 END IF
  1328.             END IF
  1329.             BRNUM=1
  1330.             FROMB=BRNUM
  1331.         END IF
  1332. C Traverse a forward "false" arc if we haven't yet
  1333.         IF (FG(3,PTR).GT.0 .AND. BRNUM.EQ.1) THEN
  1334.             IF (FG(4,FG(3,PTR)).LT.FG(4,PTR) .OR.
  1335.      +          FG(4,FG(3,PTR)).EQ.FG(4,PTR).AND.
  1336.      +          FG(1,FG(3,PTR)).EQ.-1) THEN
  1337. C arc is a backward (loop) arc -- set head refs
  1338.                 IF (.NOT.XSHEAD(FG,FGSIZE,PTR,FG(3,PTR),IODWRN))
  1339.      +              RETURN
  1340.             ELSE IF (FG(VISITD,FG(3,PTR)).EQ.0) THEN
  1341.                 PTR=FG(3,PTR)
  1342.                 BRNUM=0
  1343.                 GOTO 200
  1344.             ELSE
  1345.                 IF (FG(5,FG(3,PTR)).NE.0) THEN
  1346.                     IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
  1347.      +                              FG(5,FG(3,PTR)),IODWRN)
  1348.      +                 )RETURN
  1349.                 END IF
  1350.             END IF
  1351.             BRNUM=2
  1352.         END IF
  1353. C Traverse an element in a multiple branch if a forward arc ...
  1354.         IF (FG(2,PTR).LT.0) THEN
  1355.             NXT=-FG(2,PTR)
  1356.             J=-FG(3,PTR)
  1357. 2600        IF (FG(4,CASETB(J)).GT.FG(4,PTR)) THEN
  1358.                 IF (BRNUM.LE.0 .AND.
  1359.      +              FG(VISITD,CASETB(J)).EQ.0) THEN
  1360.                     FROMB=FROMB-BRNUM
  1361.                     PTR=CASETB(J)
  1362.                     BRNUM=0
  1363.                     GOTO 200
  1364.                 ELSE IF (BRNUM.LE.0) THEN
  1365.                     IF (FG(5,CASETB(J)).NE.0) THEN
  1366.                         IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
  1367.      +                                  FG(5,CASETB(J)),IODWRN))
  1368.      +                      RETURN
  1369.                     END IF
  1370.                 END IF
  1371.             ELSE IF (FG(4,CASETB(J)).EQ.FG(4,PTR) .AND.
  1372.      +               FG(1,CASETB(J)).NE.-1) THEN
  1373.                 CALL ERROR('IMPOSSIBLE LOOP SITUATION')
  1374.             ELSE
  1375. C arc is a backward (loop) arc -- set head refs
  1376.                 IF (.NOT.XSHEAD(FG,FGSIZE,PTR,CASETB(J),IODWRN))
  1377.      +              RETURN
  1378.             END IF
  1379.             J=J+1
  1380.             NXT=NXT-1
  1381.             BRNUM=BRNUM-1
  1382.             IF (NXT.GT.0) GOTO 2600
  1383.         END IF
  1384. C No more forward arcs ...
  1385.         IF (FG(PTRSTK,PTR).NE.0) THEN
  1386. C FROM=PTR at this point
  1387.             BRNUM=FG(BRNSTK,PTR)+1
  1388.             PTR=FG(PTRSTK,PTR)
  1389.             FG(PTRSTK,FROM)=0
  1390.             FG(BRNSTK,FROM)=0
  1391.             FROM=FG(PTRSTK,PTR)
  1392.             FROMB=FG(BRNSTK,PTR)
  1393.             GOTO 200
  1394.         END IF
  1395.  
  1396.         ZFSHED=.TRUE.
  1397.  
  1398.         END
  1399. C ----------------------------------------------------------------------
  1400. C
  1401. C       X S H E A D   -   (Internal) Set HEAD fields in flowgraph nodes
  1402. C
  1403.  
  1404.         LOGICAL FUNCTION XSHEAD(FG,FGSIZE,PTR,HEAD,IODWRN)
  1405.         INTEGER FGSIZE,PTR,HEAD,IODWRN
  1406.         INTEGER FG(8,FGSIZE)
  1407.  
  1408.         INTEGER PTRSTK
  1409.         PARAMETER (PTRSTK=6)
  1410.  
  1411.         INTEGER I
  1412.  
  1413. C First check for irreducibility
  1414.         I=PTR
  1415.  100    IF (I.NE.HEAD .AND. I.NE.0) THEN
  1416.             I=FG(PTRSTK,I)
  1417.             GOTO 100
  1418.         END IF
  1419.         IF (I.NE.HEAD) THEN
  1420. C Yes - error message
  1421.             XSHEAD=.FALSE.
  1422.             IF (FG(1,PTR).GT.0)
  1423.      +          CALL XFERRM('Multiple-entry loop discovered',
  1424.      +                      FG(1,PTR),IODWRN)
  1425.  
  1426.         ELSE
  1427. C Normal processing
  1428.  200        XSHEAD=.TRUE.
  1429.             I=PTR
  1430.  300        IF (I.NE.HEAD) THEN
  1431.                 IF (FG(5,I).EQ.0) THEN
  1432.                     FG(5,I)=HEAD
  1433.                 ELSE IF (FG(4,FG(5,I)).LT.
  1434.      +                   FG(4,HEAD)) THEN
  1435.                     FG(5,I)=HEAD
  1436.                 END IF
  1437.                 I=FG(PTRSTK,I)
  1438.                 GOTO 300
  1439.             END IF
  1440.         END IF
  1441.  
  1442.         END
  1443. C ----------------------------------------------------------------------
  1444. C
  1445. C       Z F S D O M   -   Set the dominator pointers
  1446. C
  1447.  
  1448.         SUBROUTINE ZFSDOM(FG,FGSIZE,CASETB,MAXCAS,STARTN)
  1449.         INTEGER FGSIZE,MAXCAS,STARTN
  1450.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1451.  
  1452.         INTEGER I,J
  1453.  
  1454. C Duplicate the count (in fg_follow)
  1455.  
  1456.         DO 100 I=1,FGSIZE
  1457.             FG(8,I)=FG(7,I)
  1458.  100    CONTINUE
  1459.  
  1460. C Begin at the beginning
  1461.  
  1462.         I=STARTN
  1463.  
  1464.  200    CONTINUE
  1465. C Here to visit a node - number I
  1466.         IF (FG(2,I).GT.0) THEN
  1467. C the true outarc
  1468.             CALL XDOMIN(FG,FGSIZE,FG(2,I),I)
  1469. C the false outarc, if any
  1470.             IF (FG(3,I).GT.0)
  1471.      +          CALL XDOMIN(FG,FGSIZE,FG(3,I),I)
  1472.         ELSE IF (FG(2,I).LT.0) THEN
  1473. C Case statement
  1474.             DO 300 J=-FG(3,I),-FG(3,I)-FG(2,I)-1
  1475.                 CALL XDOMIN(FG,FGSIZE,CASETB(J),I)
  1476.  300        CONTINUE
  1477.         END IF
  1478. C Make sure we don't ever visit this one again
  1479.         FG(8,I)=-1
  1480.  
  1481. C Find a node we can visit next
  1482.         DO 400 I=1,FGSIZE
  1483.             IF (FG(8,I).EQ.0 .AND.
  1484.      +          FG(4,I).NE.0) GOTO 200
  1485.  400    CONTINUE
  1486.  
  1487. C If we are here we must have finished; better clear up the follow fld
  1488.  
  1489.         DO 500 I=1,FGSIZE
  1490.             IF (FG(8,I).NE.-1 .AND. FG(4,I).NE.0)
  1491.      +          CALL ERROR('INTERNAL ERROR: SETDOM FAILED')
  1492.             FG(8,I)=0
  1493.  500    CONTINUE
  1494.  
  1495.         END
  1496. C ----------------------------------------------------------------------
  1497. C
  1498. C       Z F I C N T   -   Count number of forward inarcs entering each
  1499. C                         node.
  1500. C
  1501.  
  1502.         SUBROUTINE ZFICNT(FG,FGSIZE,CASETB,MAXCAS)
  1503.         INTEGER FGSIZE,MAXCAS
  1504.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1505.  
  1506.         INTEGER I,J
  1507.  
  1508.         DO 200 I=1,FGSIZE
  1509.             IF (FG(2,I).GT.0 .AND. FG(4,I).GT.0) THEN
  1510.                 IF (FG(4,I).LT.FG(4,FG(2,I)) .OR.
  1511.      +              FG(4,I).EQ.FG(4,FG(2,I)) .AND.
  1512.      +              FG(1,I).EQ.-1)
  1513.      +              FG(7,FG(2,I))=
  1514.      +                  FG(7,FG(2,I))+1
  1515.                 IF (FG(3,I).GT.0) THEN
  1516.                 IF (FG(4,I).LT.FG(4,FG(3,I)) .OR.
  1517.      +              FG(4,I).EQ.FG(4,FG(3,I)).AND.
  1518.      +              FG(1,I).EQ.-1)
  1519.      +              FG(7,FG(3,I))=
  1520.      +                  FG(7,FG(3,I))+1
  1521.                 END IF
  1522.             ELSE IF (FG(2,I).LT.0 .AND. FG(4,I).GT.0) THEN
  1523.                 DO 100 J=-FG(3,I),-FG(3,I)-FG(2,I)-1
  1524.                     IF (FG(4,I).LT.FG(4,CASETB(J)) .OR.
  1525.      +                  FG(4,I).EQ.FG(4,CASETB(J)) .AND.
  1526.      +                  FG(1,I).EQ.-1)
  1527.      +                  FG(7,CASETB(J))=
  1528.      +                      FG(7,CASETB(J))+1
  1529.  100            CONTINUE
  1530.             END IF
  1531.  200    CONTINUE
  1532.  
  1533.         END
  1534. C ----------------------------------------------------------------------
  1535. C
  1536. C       X D O M I N   -   Say a node may dominate another (or may not)
  1537. C
  1538.  
  1539.         SUBROUTINE XDOMIN(FG,FGSIZE,NODE,DOM)
  1540.         INTEGER FGSIZE,NODE,DOM
  1541.         INTEGER FG(8,FGSIZE)
  1542.  
  1543.         INTEGER I,J
  1544.  
  1545.         IF (FG(4,NODE).GT.FG(4,DOM) .OR.
  1546.      +      FG(4,NODE).EQ.FG(4,DOM) .AND.
  1547.      +      FG(1,DOM).EQ.-1) THEN
  1548.             IF (FG(6,NODE).EQ.0) THEN
  1549.                 FG(6,NODE)=DOM
  1550.             ELSE IF (FG(6,NODE).NE.DOM) THEN
  1551.                 I=FG(6,NODE)
  1552.  100            J=DOM
  1553.  200            IF (I.NE.J) THEN
  1554.                     J=FG(6,J)
  1555.                     IF (J.NE.0) GOTO 200
  1556.                     I=FG(6,I)
  1557.                     IF (I.NE.0) GOTO 100
  1558.                     CALL ERROR('IMPOSSIBLE ERROR: NO DOMINATOR FOUND')
  1559.                 ELSE
  1560.                     FG(6,NODE)=J
  1561.                 END IF
  1562.             END IF
  1563.             FG(8,NODE)=FG(8,NODE)-1
  1564.         END IF
  1565.  
  1566.         END
  1567. C ----------------------------------------------------------------------
  1568. C
  1569. C       Z F F O L L   -   Make FOLLOW sets
  1570. C
  1571.  
  1572.         SUBROUTINE ZFFOLL(FG,FGSIZE,CASETB,MAXCAS)
  1573.         INTEGER FGSIZE,MAXCAS
  1574.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  1575.  
  1576.         INTEGER I,J,NXT,NJUMPS,TO
  1577.  
  1578.         EXTERNAL ERROR
  1579.  
  1580.         DO 3000 I=1,FGSIZE
  1581. C Calculate FOLLOW set for node I
  1582.             IF (FG(1,I).EQ.(-1)) THEN
  1583. C REPEAT FOLLOW set:
  1584.                 DO 2800 J=1,FGSIZE
  1585. C require HEAD(I)=HEAD(J) (and DOM(J) not to be undefined)
  1586.                     IF (FG(5,I).EQ.FG(5,J) .AND.
  1587.      +                  FG(6,J).NE.0) THEN
  1588. C and DOM(J) in loop tail of I,
  1589. C i.e. HEAD(DOM(J))=I or HEAD(HEAD(DOM(J)))=I or ...
  1590.                         NXT=FG(6,J)
  1591. 2700                    IF (FG(5,NXT).NE.I) THEN
  1592.                             NXT=FG(5,NXT)
  1593.                             IF (NXT.NE.0) GOTO 2700
  1594.                         ELSE IF (FG(8,J).NE.0) THEN
  1595.                             CALL ERROR(
  1596.      +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT')
  1597.                         ELSE
  1598.                             FG(8,J)=I
  1599.                         END IF
  1600.                     END IF
  1601. 2800            CONTINUE
  1602.             ELSE
  1603.                 DO 2900 J=1,FGSIZE
  1604. C SLC FOLLOW set:
  1605. C J in FOLLOW(I) iff HEAD(J)=HEAD(I) and DOM(J)=I
  1606. C IF FOLLOW set:
  1607. C same except also require number of forward inarcs >= 2
  1608. C CASE FOLLOW set: (similar to IF)
  1609. C ditto only number of forward inarcs must be > number of jumps
  1610. C to that particular case
  1611.                     IF (FG(5,J).EQ.FG(5,I) .AND.
  1612.      +                  I.EQ.FG(6,J)) THEN
  1613.                         IF (FG(2,I).LT.0) THEN
  1614.                             NJUMPS=0
  1615.                             NXT=-FG(3,I)
  1616.                             TO=-FG(3,I)-FG(2,I)-1
  1617. 2850                        IF (CASETB(NXT).EQ.J) NJUMPS=NJUMPS+1
  1618.                             NXT=NXT+1
  1619.                             IF (NXT.LE.TO) GOTO 2850
  1620.                             IF (FG(7,J).GT.NJUMPS) THEN
  1621.                                 IF (FG(8,J).NE.0) CALL ERROR(
  1622.      +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT (CASE STMT)')
  1623.                                 FG(8,J)=I
  1624.                             END IF
  1625.                         ELSE IF (FG(3,I).EQ.0 .OR.
  1626.      +                           FG(7,J).GE.2) THEN
  1627.                             IF (FG(8,J).NE.0) CALL ERROR(
  1628.      +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT')
  1629.                             FG(8,J)=I
  1630.                         END IF
  1631.                     END IF
  1632. 2900            CONTINUE
  1633.             END IF
  1634. 3000    CONTINUE
  1635.  
  1636.         END
  1637. C ----------------------------------------------------------------------
  1638. C
  1639. C       X F U L E R   -   report an Undefined Label ERror
  1640. C
  1641.  
  1642.         SUBROUTINE XFULER(STPTR,LBSYMP,IODWRN)
  1643.         INTEGER STPTR,LBSYMP,IODWRN
  1644.  
  1645.         INTEGER SYMBOL(8),TEXT(1322)
  1646.  
  1647.         INTEGER ZYGPUS,ZYGTXF
  1648.         EXTERNAL ZYGPUS,ZYGTXF,ZCHOUT,ZYGTSY,ZYGTST,PUTLIN,PUTCH
  1649.  
  1650. C---------------------------------------------------------
  1651. C    TOOLPACK/1    Release: 2.5
  1652. C---------------------------------------------------------
  1653. C
  1654. C Common block and access functions for YP parse tree
  1655. C
  1656. C---------------------------------------------------------
  1657. C    TOOLPACK/1    Release: 2.5
  1658. C---------------------------------------------------------
  1659.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1660.         INTEGER ROOT,TREE(4,46339),TRETOP
  1661.  
  1662.         SAVE /XCTREE/
  1663. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1664.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1665.  
  1666.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1667.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1668.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1669.         DOWN(JABC12)=TREE(2,JABC12)
  1670.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1671.         NATTR(JABC12)=TREE(4,JABC12)
  1672.  
  1673.         CALL ZCHOUT('Undefined label ',IODWRN)
  1674.         CALL ZYGTSY(LBSYMP,SYMBOL)
  1675.         CALL ZYGTST(SYMBOL(2),TEXT)
  1676.         CALL PUTLIN(TEXT,IODWRN)
  1677.         CALL ZCHOUT(' at statement ',IODWRN)
  1678.         CALL ZPTINT(NATTR(STPTR)-NATTR(DOWN(UP(STPTR)))+1,1,IODWRN)
  1679.         CALL ZCHOUT(' in ',IODWRN)
  1680.         CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
  1681.         CALL ZYGTST(SYMBOL(2),TEXT)
  1682.         CALL PUTLIN(TEXT,IODWRN)
  1683.         CALL PUTCH(10,IODWRN)
  1684.  
  1685.         END
  1686. C ----------------------------------------------------------------------
  1687. C
  1688. C       X F E R R M   -   Error Message
  1689. C
  1690.  
  1691.         SUBROUTINE XFERRM(STRING,STPTR,IODWRN)
  1692.         CHARACTER*(*) STRING
  1693.         INTEGER STPTR,IODWRN
  1694.  
  1695. C---------------------------------------------------------
  1696. C    TOOLPACK/1    Release: 2.5
  1697. C---------------------------------------------------------
  1698.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  1699.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  1700.  
  1701.         SAVE /XCSTRI/
  1702.  
  1703. C---------------------------------------------------------
  1704. C    TOOLPACK/1    Release: 2.5
  1705. C---------------------------------------------------------
  1706.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1707.         INTEGER NSYMS,NPUS,PUIDX(250),
  1708.      +          SYMBOL(8,5003)
  1709.         LOGICAL MODFLG
  1710.  
  1711.         SAVE /XCSYMS/
  1712.  
  1713.         INTEGER NODE
  1714.  
  1715.         INTEGER ZYPUSY
  1716.         EXTERNAL ZYPUSY
  1717.  
  1718. C---------------------------------------------------------
  1719. C    TOOLPACK/1    Release: 2.5
  1720. C---------------------------------------------------------
  1721. C
  1722. C Common block and access functions for YP parse tree
  1723. C
  1724. C---------------------------------------------------------
  1725. C    TOOLPACK/1    Release: 2.5
  1726. C---------------------------------------------------------
  1727.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1728.         INTEGER ROOT,TREE(4,46339),TRETOP
  1729.  
  1730.         SAVE /XCTREE/
  1731. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1732.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1733.  
  1734.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1735.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1736.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1737.         DOWN(JABC12)=TREE(2,JABC12)
  1738.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1739.         NATTR(JABC12)=TREE(4,JABC12)
  1740.  
  1741.         NODE=STPTR
  1742.         IF (NTYPE(UP(NODE)).EQ.56) NODE=UP(NODE)
  1743.         CALL ZCHOUT(STRING,IODWRN)
  1744.         CALL ZCHOUT(' at statement ',IODWRN)
  1745.         CALL ZPTINT(NATTR(NODE)-NATTR(DOWN(UP(NODE)))+1,1,IODWRN)
  1746.         CALL ZCHOUT(' in ',IODWRN)
  1747.         CALL PUTLIN(STRTXT(SYMBOL(2,ZYPUSY(UP(NODE)))),IODWRN)
  1748.         CALL PUTCH(10,IODWRN)
  1749.  
  1750.         END
  1751.